unit Key;

interface

// ie: GoogleAuthenticatorCode('JBSWY3DPEHPK3PXP')
function GoogleAuthenticatorCode(const Secret: WideString): WideString;
function GetSerialNum: string;
function StringToHex(str1, Separator: String): String;

implementation

uses
  Windows, SysUtils;

function GetSerialNum: string;
var
  SerialNum: DWORD;
  a, b: DWORD;
  Buffer: array [0 .. 255] of char;
begin
  result := '';
  try
    GetVolumeInformation(PwideChar('c:\'), Buffer, sizeof(Buffer), @SerialNum,
      a, b, nil, 0);
  finally
    result := IntToStr(SerialNum);
  end;
end;

function StringToHex(str1, Separator: String): String;
var
  buf: String;
  i: integer;
begin
  buf := '';
  for i := 1 to Length(str1) do
  begin
    buf := buf + IntToHex(Byte(str1[i]), 2) + Separator;
  end;
  result := buf;
end;

function UnixTime: Int64;
var
  SystemTime: TSystemTime;
begin
  GetSystemTime(SystemTime);
  with SystemTime do
    result := Round((EncodeDate(wYear, wMonth, wDay) - UnixDateDelta +
      EncodeTime(wHour, wMinute, wSecond, wMilliseconds)))
end;

type
  TBytes = array of Byte;

function Base32ToBin(const Str: string): TBytes;
const
  Base32Chars: string = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ234567';
  // RFC 4648/3548
var
  Index: integer;
  Count: integer;
  Bits: integer;
  Val: integer;
  Ofs: integer;
begin
  Count := (5 * Length(Str)) div 8;
  SetLength(result, Count);
  Bits := 0;
  Val := 0;
  Ofs := 1;
  for Index := 0 to Count - 1 do
  begin
    while Bits < 8 do
    begin
      Val := (Val shl 5) or (Pos(UpCase(Str[Ofs]), Base32Chars) - 1);
      Inc(Ofs);
      Inc(Bits, 5);
    end;
    Dec(Bits, 8);
    result[Index] := Byte(Val shr Bits);
    Val := Val and ((1 shl Bits) - 1);
  end;
end;

function IntToBytes(Value, Len: integer): TBytes;
var
  Index: integer;
begin
  SetLength(result, Len);
  for Index := Len - 1 downto 0 do
  begin
    result[Index] := Byte(Value);
    Value := Value shr 8;
  end;
end;

type
  TSHA1Context = record
    Size: integer;
    Hash: array [0 .. 4] of Cardinal; // 20 bytes
    Index: integer;
    Block: array [0 .. 63] of Byte;
  end;

procedure SHA1Reset(var Context: TSHA1Context);
begin
  Context.Size := 0;
  Context.Hash[0] := $67452301;
  Context.Hash[1] := $EFCDAB89;
  Context.Hash[2] := $98BADCFE;
  Context.Hash[3] := $10325476;
  Context.Hash[4] := $C3D2E1F0;
  Context.Index := 0;
end;

function SHA1CircularShift(Bits, data: Cardinal): Cardinal;
begin
  result := (data shl Bits) or (data shr (32 - Bits));
end;

procedure SHA1ProcessBlock(var Context: TSHA1Context);
const
  K: array [0 .. 3] of Cardinal = ($5A827999, $6ED9EBA1, $8F1BBCDC, $CA62C1D6);
var
  W: array [0 .. 79] of Cardinal;
  t: integer;
  Index: integer;
  a, b, C, D, E: Cardinal;
  temp: Cardinal;
begin
  // Initialize the first 16 words in the array W
  for t := 0 to 15 do
  begin
    index := 4 * t;
    W[t] := Context.Block[index] shl 24 or Context.Block[index + 1] shl 16 or
      Context.Block[index + 2] shl 8 or Context.Block[index + 3];
  end;
  for t := 16 to 79 do
  begin
    W[t] := SHA1CircularShift(1, W[t - 3] xor W[t - 8] xor W[t - 14]
      xor W[t - 16]);
  end;
  a := Context.Hash[0];
  b := Context.Hash[1];
  C := Context.Hash[2];
  D := Context.Hash[3];
  E := Context.Hash[4];
  for t := 0 to 19 do
  begin
    temp := SHA1CircularShift(5, a) + ((b and C) or ((not b) and D)) + E +
      W[t] + K[0];
    E := D;
    D := C;
    C := SHA1CircularShift(30, b);
    b := a;
    a := temp;
  end;
  for t := 20 to 39 do
  begin
    temp := SHA1CircularShift(5, a) + (b xor C xor D) + E + W[t] + K[1];
    E := D;
    D := C;
    C := SHA1CircularShift(30, b);
    b := a;
    a := temp;
  end;
  for t := 40 to 59 do
  begin
    temp := SHA1CircularShift(5, a) + ((b and C) or (b and D) or (C and D)) + E
      + W[t] + K[2];
    E := D;
    D := C;
    C := SHA1CircularShift(30, b);
    b := a;
    a := temp;
  end;
  for t := 60 to 79 do
  begin
    temp := SHA1CircularShift(5, a) + (b xor C xor D) + E + W[t] + K[3];
    E := D;
    D := C;
    C := SHA1CircularShift(30, b);
    b := a;
    a := temp;
  end;
  Inc(Context.Hash[0], a);
  Inc(Context.Hash[1], b);
  Inc(Context.Hash[2], C);
  Inc(Context.Hash[3], D);
  Inc(Context.Hash[4], E);
  Context.Index := 0;
end;

procedure SHA1Input(var Context: TSHA1Context; const data: TBytes);
var
  i: integer;
begin
  for i := 0 to Length(data) - 1 do
  begin
    Context.Block[Context.Index] := data[i];
    Inc(Context.Size);
    Inc(Context.Index);
    if Context.Index = 64 then
      SHA1ProcessBlock(Context);
  end;
end;

procedure SHA1PadMessage(var Context: TSHA1Context);
var
  i: integer;
begin
  i := Context.Index;
  Context.Block[i] := $80;
  Inc(i);
  if i > 56 then
  begin
    FillChar(Context.Block[i], 64 - i, 0);
    Context.Index := 64;
    SHA1ProcessBlock(Context);
    FillChar(Context.Block[0], 56, 0);
  end
  else
  begin
    FillChar(Context.Block[i], 56 - i, 0);
  end;
  Context.Index := 56;
  // Store the message length as the last 8 bytes
  Context.Block[56] := 0;
  Context.Block[57] := 0;
  Context.Block[58] := 0;
  Context.Block[59] := Context.Size shr 29;
  Context.Block[60] := Context.Size shr 21;
  Context.Block[61] := Context.Size shr 13;
  Context.Block[62] := Context.Size shr 5;
  Context.Block[63] := Context.Size shl 3;
  SHA1ProcessBlock(Context);
end;

function SHA1Result(var Context: TSHA1Context): TBytes;
var
  i: integer;
begin
  SHA1PadMessage(Context);
  SetLength(result, 20);
  for i := 0 to 19 do
  begin
    result[i] := Byte(Context.Hash[i shr 2] shr (8 * (3 - (i and 3))));
  end;
end;

function XorBytes(const Src: TBytes; Value: Byte): TBytes;
var
  Len: integer;
  Index: integer;
begin
  SetLength(result, 64);
  Len := Length(Src);
  if Len > 64 then
    Len := 64
  else
    FillChar(result[Len], 64 - Len, Value);
  for Index := 0 to Len - 1 do
  begin
    result[Index] := Src[Index] xor Value;
  end;
end;

function HMAC_SHA1(const Key, Value: TBytes): TBytes;
var
  opad: TBytes;
  ipad: TBytes;
  sha1: TSHA1Context;
begin
  opad := XorBytes(Key, $5C);
  ipad := XorBytes(Key, $36);
  // Result := SHA1(opad + SHA1(ipad + Value))
  SHA1Reset(sha1);
  SHA1Input(sha1, ipad);
  SHA1Input(sha1, Value);
  result := SHA1Result(sha1);
  SHA1Reset(sha1);
  SHA1Input(sha1, opad);
  SHA1Input(sha1, result);
  result := SHA1Result(sha1);
end;

function BytesToHex(const Value: TBytes): string;
const
  hx: array [0 .. $F] of char = '0123456789abcdef';
var
  Len: integer;
  Idx: integer;
  b: Byte;
begin
  Len := Length(Value);
  SetLength(result, 2 * Len);
  for Idx := 0 to Len - 1 do
  begin
    b := Value[Idx];
    result[2 * Idx + 1] := hx[b shr 4];
    result[2 * Idx + 2] := hx[b and $F];
  end;
end;

function GoogleAuthenticatorCode(const Secret: WideString): WideString;
var
  Key: TBytes;
  epoch: TBytes;
  hmac: TBytes;
  offset: integer;
  Index: integer;
  otp: Cardinal;
begin
  Key := Base32ToBin(Secret);
  // WriteLn('Key = ', BytesToHex(key));
  epoch := IntToBytes(UnixTime div 30, 8);
  // WriteLn('Epoch = ', BytesToHex(epoch));
  hmac := HMAC_SHA1(Key, epoch);
  // WriteLn('HMac = ', BytesToHex(hmac));
  offset := hmac[19] and $F;
  otp := 0;
  for Index := 0 to 3 do
  begin
    otp := otp shl 8 + hmac[offset + Index];
  end;
  otp := otp and $7FFFFFFF;
  result := IntToStr(otp mod 1000000);
  if Length(result) < 6 then
    result := StringOfChar('0', 6 - Length(result)) + result;
end;

end.
